home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / Module source / docmod < prev    next >
Text File  |  1994-06-24  |  12KB  |  430 lines
  1. \ 12.25.93    rfl    added need; fwind now moved out of way and dwind selected
  2. \  1.03.94    rfl    fixed copy, paste etc.
  3.  
  4. :module docmod
  5.  
  6. // ctl
  7. // ctlwind
  8. // vscroll
  9. // textedit
  10.  
  11. 0 value eop
  12.  
  13. : getWidth    option?
  14.     IF -1 -> eop ELSE getvrect: actw drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop THEN ;
  15.  
  16.  
  17. : (marks) ( cfa filemk --)
  18.     over @ = IF  >name dup
  19.                   8 .r  3 spaces n>count type out eop >
  20.                   IF cr 0 -> out ELSE 26 out over mod - spaces THEN
  21.              ELSE drop
  22.              THEN ?pause ;
  23.  
  24. \ same as 'words'..lists all filemarks
  25. \ hold down option key to get single column
  26. : marks  getWidth 0 -> out
  27.     base >r hex
  28.     'c (marks) filemk trav cr
  29.     r> -> base ; 
  30.  
  31.  
  32. 0 value mkCfa    \ the file mark cfa
  33.  
  34. \ define a word to check each cfa in the fmark vocab, and if it is earlier
  35. \  in the dictionary than the cfa of the word we are testing to see which
  36. \  file it is in, then we must have found the mark...set a flag.
  37. : (findMk)    \ ( cfa wordcfa -- )  
  38.            over > IF dup  -> mkCfa @ filemk = -> endTrav? ELSE drop THEN ;
  39.     
  40. \ find first mark above the wordcfa - returns true if mark found
  41. : findFMark    \ ( wordcfa -- cfa t or f)        - could also be addr
  42.     LoCase
  43.     'c (findMk)  swap trav
  44.     UpCase
  45.     endTrav? IF mkCfa true ELSE false THEN ;
  46.  
  47. \ get source name from mark
  48. : srcName  ( cfa -- addr len) findFMark not abort" No Mark"
  49.      >name n>count  ;
  50.  
  51. : (forget) ( pfa --)    dup nfa >line -> dp lfa @ current ! ;
  52.  
  53. : mforget LoCase [compile] ' (forget) Upcase ;
  54.  
  55. \ forget to last mark
  56. : FM here findFMark 0= abort" no mark found"
  57.      >body (forget) ;
  58.  
  59.  
  60. \ reload last file, forgetting to mark
  61. : RL here srcname fm new: loadfile
  62.     name: topfile interpret: topfile remove: loadfile ;
  63.  
  64. \ *** reload sources from named mark
  65.  
  66. string LoadList    \ make the filelist here
  67. string tempStr    \ use in place of parmstr, since parmstr defined in Frontend
  68.  
  69. \ identify all source names from latest to the entered mark and fill filelist
  70. : (files) ( cfa cfa0 --)
  71.     over <=
  72.     IF dup @ filemk =
  73.         IF " // " put: tempStr >name n>count add: tempStr  13 +: tempStr lock: tempStr
  74.            get: tempStr start: LoadList insert: LoadList unlock: tempStr
  75.         ELSE drop THEN
  76.     ELSE drop true -> endTrav?
  77.     THEN ;
  78.  
  79. \ find filenames
  80. : files ( -- pfa) new: tempStr
  81.     clear: LoadList 'c (files) locase [compile] ' dup >r upcase 4- latest (trav) r>
  82.     release: tempStr ;
  83.  
  84. : loadKey
  85.     next: LoadList 0=
  86.     IF rekey 13 THEN ;    \ simulate a terminal cr
  87.  
  88. \ interpret from the scrap
  89. : Doit size: loadlist 0>
  90.     IF start: loadlist 'c loadKey -> keyVec  THEN sp! mp! quit ;
  91.  
  92. \ interpret LoadList
  93. : reload loadKey doit ;
  94.  
  95.  
  96. \ make file list, forget to the mark, and the reload the list.
  97. \ usage:  /// filename
  98. \ will rebuild from 'filename' to latest
  99. : /// new: LoadList files (forget) reload release: LoadList ;
  100.  
  101. : toScrap 0 call zeroScrap
  102.         global teScrpLength w@ 'type TEXT global teScrpHandle @ >ptr +base
  103.         call putScrap drop ;
  104.  
  105. \ 1.31.92    rfl    modified recalscroll
  106. \ DISABLE MESSAGE SENT AFTER CLOSED!!!
  107.  
  108. \ class that is only for displaying scrolling, word wrapped text
  109. \  has a vertical scroll bar attached at right, with grow box.
  110. \  scroll region is entire window minus the scroll bar
  111. :CLASS TeScrollRect <super TextEdit
  112.  
  113.     var        myVScroll        \ scrollbar ptr
  114.     rect    boundsRect        \ turns out is content region 
  115.     int        atLine            \ internal use for keeping text at same line after grow
  116.     var        myWindow        \ used to determine if window is active for scroll bar
  117.  
  118.   :M putScroll: ( n --) put: myVScroll ;M
  119.  
  120.   :M lineHeight: ( -- n) m@ >ptr 24 + w@ ;M
  121.   :M nlines: ( -- n) m@ >ptr 94 + w@ ;M
  122.  
  123.   :M putLine: ( n --) put: atLine ;M
  124.  
  125. \ returns top line
  126.   :M where: ( -- line#)  getTopY: destrect    \ subtract y0 of original dest rect    
  127.     m@ >ptr getTopY: rect - lineHeight: self / ;M    \ get y0 of internal dest rect
  128.  
  129. \  :M topChar: m@ >ptr 96 + where: self 2* + w@ ;M
  130.  
  131. \ get number of whole lines
  132.   :M visibleLines: ( -- n) ptr: self 8+ size: rect swap drop lineheight: self / ;M
  133.  
  134. \ boundsRect of two textctls can't be too close vertically: > 4 pixels 
  135.   :M putRect: { l t r b  -- } l t r b put: boundsRect
  136.     l 4+ t 2+ r 18 - b 2-  putRect: super m@
  137.     IF get: destRect drop over visibleLines: self lineHeight: self * +
  138.         ptr: self 8+ put: rect
  139.     THEN ;M
  140.  
  141. \ return max first line
  142.   :M maxRange: ( -- n) nlines: self visibleLines: self -  1+ ;M
  143.  
  144.   :M new: { myWind -- } myWind put: myWindow
  145.     myWind new: super
  146.     getBotX: boundsRect 15 - getTopY: boundsRect
  147.     size: boundsRect swap drop myWind new: [ obj: myVScroll ]
  148.     disable: [ obj: myVScroll ]
  149.     1 1 putRange: [ obj: myVScroll ] ;M
  150.  
  151.   :M close: close: [ obj: myVScroll ] close: super 'c docmod munlock ;M
  152.  
  153.   :M draw: pushPort set: [ obj: myWindow ] draw: super popPort ;M
  154.  
  155. \ move text record to line# as first line in rect
  156.   :M moveto: { line# \ y -- } 0
  157.     line#  maxRange: self 1- min 0 max \ negate  \ where we want it to be
  158.     where: self                                \ where are we now?
  159.     - lineHeight: self * negate                \ translate to pixel offset
  160.     m@ >ptr offset: rect line# put: atLine draw: self
  161.     where: self 1+ put: [ obj: myVScroll ] ;M
  162.  
  163. \ recalibrate scroll bar size, range, and set text
  164.   :M recalScroll: 1 maxRange: self 1 max
  165.     putRange: [ obj: myVScroll ]
  166.     nlines: self visibleLines: self > active: [ obj: myWindow ] and
  167.     IF enable: [ obj: myVScroll ] THEN
  168.      get: atLine maxRange: self 1- min 0 max moveto: self            \ stay at about where we were before grow
  169.       ;M
  170.     
  171.   :M find: { addr len \ myText offset off1 -- offset line T or F }
  172.         heap> sarray -> myText new: myText 13 putChar: mytext
  173.         getText: super place: myText
  174.         start: myText addr len myText indexof: string
  175.         IF 1- -> offset
  176.              ptr: myText offset + bl parse -> off1 drop
  177.              bl parse offset + off1 + offset swap setSelect: self 2drop
  178.             limit: myText 1
  179.             DO offset i ^elem: myText 0 ^elem: myText - <
  180.                 IF i leave THEN
  181.             LOOP moveto: self recalscroll: self
  182.         THEN release: myText dispose> myText ;M
  183.  
  184. \ recal really slows things down
  185.   :M addText: ( addr len --) addtext: super recalScroll: self ;M
  186.  
  187.   :M put: ( addr len --) clear: super addText: self ;M
  188.  
  189.   :M grow: ( l t r b -- ) where: self put: atLine
  190.      putRect: self
  191.     16 size: boundsRect swap drop 15 - size: [ obj: myVScroll ]
  192.     getBotX: boundsRect 15 - getTopY: boundsRect moveto: [ obj: myVScroll ]
  193.     recal: self
  194.     recalScroll: self ( draw: self)  ;M
  195.  
  196.   :M activate: activate: super enable: [ obj: myVScroll ] ;M
  197.   :M deactivate: deactivate: super disable: [ obj: myVScroll ] ;M
  198. \  :M exec: activate: self click: super ;M
  199.  
  200. ;CLASS
  201.  
  202.  
  203. \ class to contain the teScrollRect
  204. :CLASS ScrollWind <super ctlWind
  205.  
  206.     var     myTextPane    \ pointer to teScrollRect
  207.  
  208.   :M putPane: ( n --) put: myTextPane ;M
  209.  
  210.   :M close:  close: [ obj: myTextPane ] close: super ;M
  211.  
  212. \ draw only the grow box, no horizontal scroll lines
  213.   :M clipGrow: { \ b r scratchRgn -- } 
  214.     get: growFlg
  215.     IF 0 call NewRgn -> scratchRgn
  216.         scratchRgn call getClip
  217.         getRect: self 2swap 2drop -> b -> r
  218.         r 15 - 0 r b put: tempRect clip: tempRect
  219.         @xy (abs) call DrawGrowIcon gotoxy
  220.         scratchRgn call setClip scratchRgn call disposeRgn
  221.     THEN ;M
  222.  
  223. \ same draw as window, except that we clip the grow rect when drawing it.
  224.     :M  DRAW:    get: fPrect
  225.         (abs) call BeginUpdate
  226.         savePort @xy set: self
  227.         clipGrow: self
  228.         exec: draw    gotoxy    \ call user draw routine
  229.         (abs) call EndUpdate 
  230.         put: fPrect 
  231.         draw: [ obj: myTextPane ] restport ;M
  232.  
  233.     \ ( -- )  response to activate event - want to draw only grow rect
  234.     :M  ENABLE:  
  235.         ^base -> actW                \ commence idle handler
  236.         set: self
  237.         clipGrow: self
  238.         activate: [ obj: myTextPane ]
  239.         exec: Enact ;M
  240.  
  241.   :M disable: deactivate: [ obj: myTextPane ]
  242.         0 -> actw clipGrow: self exec: deact ;M
  243.  
  244.   :M (grow): getVrect: self put: temprect -4 0 offset: temprect clear: temprect
  245.         getrect: self 2+ swap 1+ swap put: temprect -1 -1 offset: temprect
  246.         get: temprect grow: [ obj: myTextPane ] ;M
  247.  
  248.  :M grow: Get: growFlg
  249.         IF     0 (abs) Where: fEvent  abs: growrect
  250.             call GrowWindow -dup
  251.             IF unpack size: self (grow): [ ^base ] setView: self THEN
  252.         THEN  select: self ;M
  253.  
  254.   :M new: alive: super not
  255.     IF new: super ^base new: [ obj: myTextPane ] 
  256.         setLimits: self \ activate: [ obj: myTextPane ]
  257.         (grow): [ ^base ]
  258.     THEN ( select: self) ;M
  259.  
  260.  
  261.   :M addText: ( addr len --) alive: self
  262.     IF pushPort >r set: self addText: [ obj: myTextPane ] r> popPort
  263.     ELSE 2drop
  264.     THEN ;M
  265.  
  266.   :M print: ( addr len --) alive: self
  267.     IF pushPort >r set: self put: [ obj: myTextPane ] r> popPort
  268.     ELSE 2drop
  269.     THEN ;M
  270.  
  271.   :M cut:     teCut: [ obj: myTextPane ] toScrap ;M
  272.   :M copy:   teCopy: [ obj: myTextPane ] toScrap ;M
  273.   :M paste: tePaste: [ obj: myTextPane ] ;M
  274.  
  275.   :M key: { char  -- } char $ ff and -> char
  276.         command?
  277.         IF char 
  278.             CASE
  279.                 ascii c  char ascii C = or    OF Copy:  self ENDOF
  280.                 ascii x  char ascii X = or    OF Cut:   self ENDOF
  281.                 ascii v  char ascii V = or    OF paste: self ENDOF
  282.             ENDCASE
  283.         ELSE  char key: [ obj: myTextPane ] 
  284.         THEN  ;M
  285.  
  286.   :M content:
  287.     pushPort ^base set: grafPort ^base ctlhit? not
  288.     IF select: self click: [ obj: myTextPane ]
  289.     THEN  popPort ;M
  290.  
  291.   :M idle: ptIn: [ obj: myTextPane ]
  292.         IF ibeamCurs idle: [ obj: myTextPane ] ELSE arrowCurs THEN exec: idle ;M
  293.  
  294. ;CLASS
  295.  
  296. \ instantiate objects
  297. ScrollWind dwind
  298. tescrollrect dPane
  299. vscroll dscroll
  300. dscroll putScroll: dPane
  301. dPane putPane: dwind
  302.  
  303. \ 2  2 270 120 putrect:    dPane
  304.  
  305. 270 61 640 300 true setgrow: dwind
  306.  
  307. : buildDWind pushPort alive: dwind not
  308.     IF  2 40 542 200 put: temprect
  309.         temprect 0 0 docwind false true new: dwind
  310.     THEN dup call selectWindow popPort
  311.     1 'c docmod 12 + @ $ ffffff and c! ;    \ force the module to be locked
  312.                                             \ until window is closed
  313.  
  314. : lndn get: myCtl 1+ dup put: myCtl maxRange: dPane <=
  315.     IF 0 lineHeight: dPane negate scroll: dPane THEN ;
  316. : lnup get: myCtl 1- dup put: myCtl  0>
  317.     IF 0 lineHeight: dPane  scroll: dPane THEN ;
  318. : pgdn get: myCtl visibleLines: dPane 1- + put: myCtl get: myCtl 1- moveto: dPane ;
  319. : pgup get: myCtl visibleLines: dPane 1- - put: myCtl get: myCtl 1- moveto: dPane ;
  320. : doth get: myCtl put: myCtl get: myCtl 1- moveto: dPane ;
  321.  
  322. 5 'cfas lnup lndn pgup pgdn doth actions: dscroll
  323.  
  324. 0 value srcOpen    \ store mkcfa or 0.
  325.  
  326. : NoSrc false -> srcOpen ;
  327. : dwindInterp  \ \ for testing textctl entries
  328.     BEGIN
  329.         next: fevent
  330.         IF active: dwind
  331.             IF drop key: dwind ELSE become quit THEN
  332.         THEN
  333.     AGAIN ;
  334.  
  335. 2 'cfas null null setAct: dwind
  336. 4 'cfas NoSrc dwindInterp null null actions: dwind
  337.  
  338. : loadr ( addr len --)
  339.     new: loadfile
  340.      name: topFile
  341.     open: topFile dup konstant fnfErr =
  342.     abort" file not in pathList"
  343.     abort" file error"
  344.     topFile size: topFile read: tempstr drop
  345.     builddwind
  346.     getName: topFile title: dwind
  347.     remove: loadfile   ;
  348.  
  349. : moveFwind { \ l t r b -- }
  350.     set: dwind 0 l->g unpack -> t drop
  351.     getRect: dwind ++> t drop 2drop
  352.     getRect: fwind -> b -> r 2drop
  353.     screenbits 20 - t b + min -> b drop 2drop
  354.     r b t -  size: fwind
  355.     2 t 20 + moveto: fwind set: fwind select: fwind
  356.     fixGrow: fwind enable: fwind ;
  357.     
  358. : see { \ xline wordPfa -- }
  359.     docs 0= abort" +docs not set"
  360.     @word count sfind
  361.     IF drop -> wordPfa
  362.         wordPfa nfa >line w@ extend -> xline
  363.         xline -1 <>
  364.         IF wordPfa findfmark
  365.             IF    srcOpen <>
  366.                 IF  new: tempStr
  367.                     mkCFA >name n>count loadr mkCFA -> srcOpen
  368.                      xline putLine: dpane
  369.                      lock: tempstr get: tempstr print: dwind unlock: tempstr
  370.                      release: tempstr 
  371.                 ELSE xline moveto: dpane
  372.                 THEN
  373.                 moveFwind show: dwind
  374.             ELSE ." word not marked"
  375.             THEN
  376.         ELSE ." word not marked"
  377.         THEN
  378.     ELSE ." not found"
  379.     THEN  ;
  380.  
  381. \ : qhit? ( n n - b) drop $ ff and ascii q = ;
  382. \ 
  383. \ \ for testing textctl entries
  384. \ : kk BEGIN
  385. \         next: fevent
  386. \         IF actw fwind =
  387. \             IF  qhit?
  388. \                 IF exit THEN
  389. \             ELSE drop key: actw
  390. \             THEN
  391. \         THEN
  392. \     AGAIN ;
  393.  
  394. \ *************************
  395.  
  396. hex    \ compare two strings case insensitive
  397. create s=' ( addr len addr len -- tf)
  398.     201f w,        \ move.l    (sp)+,d0
  399.     225f w,        \ movea.l    (sp)+,a1
  400.     241f w,        \ move.l    (sp)+,d2
  401.     2057 w,        \ movea.l    (sp),a0
  402.     4840 w,        \ swap        d0
  403.     3002 w,        \ move.w    d2,d0
  404.     4840 w,        \ swap        d0
  405.     d1cb w,        \ adda.l    a3,a0
  406.     d3cb w,        \ adda.l    a3,a1
  407.     a03c w,        \ call equalString
  408.     0a00 w, 1 w, \ eori.b    #1,d0
  409.     2e80 w,        \ move.l    d0,(sp)
  410. next,
  411. decimal
  412.  
  413. : (include) { cfa nameAddr -- }
  414.     cfa @ filemk =
  415.     IF cfa >name n>count str255 -base count
  416.         nameAddr count s=' -> endTrav?
  417.     THEN ;
  418.  
  419. : need { \ lcurs -- }
  420.     docs 0= abort" +docs not set"
  421.     new: loadfile setName: topfile
  422.     'c (include) getName: topfile drop 1- trav endTrav? not
  423.     IF  curs -> lcurs -curs                \ Preserve cursor status
  424.         getName: topFile  3 tfont 1 tface type# 173 ( Loading: ) type 0 tface 4 tfont cr
  425.         interpret: topFile
  426.         lcurs -> curs                     \ Restore cursor status
  427.     THEN remove: loadFile ;
  428.  
  429. ;module
  430.